Predicción del precio de los jugadores en las 5 ligas de futbol europeas mas importantes

Enfoque Estadístico del Aprendizaje

#Librerias
library(tidyverse)
library(tidymodels)
library(GGally)
library(ggplot2)
library(MASS)
library(robustbase)
library(dplyr)
library(corrplot)
library(caret)
library(viridis)
library(gridExtra)
library(kableExtra)

Objetivo

El fútbol es el deporte más popular, el que tiene un mercado más grande y en el cual el valor de las transferencias de los jugadores es el más alto. En ese sentido, nos proponemos analizar las transferencias y cotizaciones de los jugadores de las cinco ligas mas importantes de Europa:

• La Liga - España
• Premier League - Inglaterra
• Bundesliga - Alemania
• Serie A - Italia
• Ligue 1 - Francia

Por este motivo, y haciendo uso de los conocimientos aportados por la materia, optamos por profundizar en el desarrollo de métodos de regresión robustos para hacer análisis predictivos, haciendo foco en la explicabilidad del modelo para predecir las transferencias de los jugadores.

El objetivo del presente trabajo consiste en la utilización distintos métodos robustos para predecir la variable objetivo: el precio de transferencia de los jugadores.

• Observar si el país de origen es una variable explicativa con respecto a la variable objetivo.
• Identificar si los ratios que demuestran el desempeño de los jugadores generan impacto sobre la transferencia de los jugadores.
• Utilizar la regresión regresión de mínimos cuadrados ponderados, regresión de mínimos cuadrados robustos (Huber).
• Comparar el desempeño de los distintos modelos para predecir la variable objetivo.

Introducción

En el método lineal clásico se utiliza el método de cuadrados mínimos para encontrar los parámetros \(\beta\).

La función de pérdida que se quiere minimizar es la suma del cuadrado de los residuos.

\[ g(a, b) = \sum_{i=1}^n \left( Y_i - \left( a + b X_i \right) \right)^2 \quad \text{(1)} \]

En los modelos lineales robustos queremos cambiar la función de perdida tal que:

• Sea Insensible a valores extremadamente grandes o outliers(o residuos grandes)
• Crezca menos que mínimos cuadrados cuando miramos lo suficientemente lejos del cero
• Tenga Alta eficiencia: si los datos de la muestra siguieran el modelo de regresión con errores normales, queremos que el estimador (beta) que el método robusta calcula se parezca al de mínimos cuadrados, por lo que la función de pérdida que el método robusto calcula debería parecerse al de mínimos cuadrado.

\[ g(a, b) = \sum_{i=1}^n \rho \left( \frac{Y_i - \left( a + b X_i \right)}{s_n} \right) \quad \text{(2)} \]

Definición de la función ρ

Sea ρ: R → R una función que cumple las siguientes propiedades:

1. Dominio y Codominio
   • ρ: R → R
2. Propiedades Fundamentales
   • ρ(0) = 0
   • ρ(-u) = ρ(u) [Simetría]
   • Si 0 ≤ u ≤ v entonces ρ(u) ≤ ρ(v) [Monotonía]
   • ρ es continua
   • sup{ρ(u): u ∈ R} = 1 [Acotación]
3. Propiedad de Crecimiento Estricto
   • Si ρ(u) < 1 y 0 ≤ u < v entonces ρ(u) < ρ(v)

Esta función ρ es acotada, creciente y simétrica alrededor del cero, características que la hacen especialmente útil para la estimación robusta.

Una posibilidad es ajustar una recta usando un procedimiento de ajuste robusto, por ejemplo un MM-estimador de regresión, propuesto por Yohai [1987]. En R, esto está programado dentro de la rutina lmrob en el paquete robustbase de R. La estimación se hace en tres etapas, se propone un estimador inicial de los parámetros, a partir de él se estima a sn y manualmente se obtienen los estimadores de los parámetros a partir de ellos, minimizando la función objetivo

Existen varias funciones \(\rho\) que serán evaluadas en el presente trabajo. Por defecto, robustbase utiliza la bicuadrada (bisquare), pero también se pueden implementar lqq, welsh, optimal, etc.

Robustbase utiliza el algoritmo Iteratively Reweighted Least Squares (IRWLS) para estimar los parámetros \(\beta\). El proceso consiste en la siguientes etapas:

1. Inicializar el proceso utilizando un estimación inicial de a y b utilizando el método de cuadrados mínimos.

2. Derivar la función (2) respecto a los parámetros a y b: \[ \frac{\partial g}{\partial a} = \sum_{i=1}^{n} \psi \left(\frac{Y_i - (a + bX_i)}{s_n} \right) \cdot \frac{-1}{s_n} \quad \text{(3)} \] \[ \frac{\partial g}{\partial b} = \sum_{i=1}^{n} \psi \left(\frac{Y_i - (a + bX_i)}{s_n} \right) \cdot \frac{-X_i}{s_n} \quad \text{(4)} \]

donde

\[ \frac{d \rho(x)}{dx} = \psi(x) \quad \text{(5)} \]

3. Se calculan los pesos de cada observacion

\[ w_i = \frac{\psi \left(\frac{Y_i - (a + bX_i)}{s} \right)}{\frac{Y_i - (a + bX_i)}{s}} \quad \text{(6)} \]

4. Se multiplica a cada observación por su respectivo peso.

5. Se vuelven a estimar los parámetros a y b con una regresión ponderada.

Se repiten los pasos hasta no observar mas mejoras o hasta un máximo de iteraciones.

A continuación se muestran las funciones \(\rho\) más comunes y como se comportan los pesos de las mismas.

1. Bisquare (Tukey): \[ \rho(x) = \begin{cases} 1 - (1 - (x/k)^2)^3 & \text{si } |x| \leq k \\ 1 & \text{si } |x| > k \end{cases} \quad \text{(7)} \]

# set margins for plots
options(SweaveHooks=list(fig=function() par(mar=c(3,3,1.4,0.7),
                                            mgp=c(1.5, 0.5, 0))))
## x axis for plots:
x. <- seq(-5, 10, length.out = 1501)
source(system.file("xtraR/plot-psiFun.R", package = "robustbase", mustWork=TRUE))
getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "biweight", par = 4.685)

2. Huber: \[ \rho(x) = \begin{cases} \frac{x^2}{2} & \text{si } |x| \leq k \\ k|x| - \frac{k^2}{2} & \text{si } |x| > k \end{cases} \quad \text{(8)} \]

getOption("SweaveHooks")[["fig"]]()
plot(huberPsi, x., ylim=c(-1.4, 5), leg.loc="topright", main=FALSE)

3. Welsh: \[ \rho(x) = 1 - \exp(-x^2/k^2) \quad \text{(9)} \]

getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "Welsh", par = 2.11)

4. Hampel: \[ \rho(x) = \begin{cases} \frac{x^2}{2} & \text{si } |x| \leq a \\ a|x| - \frac{a^2}{2} & \text{si } a < |x| \leq b \\ \frac{a(c|x| - x^2/2 - bc + b^2/2)}{c-b} & \text{si } b < |x| \leq c \\ a(c - \frac{b}{2}) & \text{si } |x| > c \end{cases} \quad \text{(10)} \]

getOption("SweaveHooks")[["fig"]]()
## see also hampelPsi
p.psiFun(x., "Hampel", par = ## Default, but rounded:
           round(c(1.5, 3.5, 8) * 0.9016085, 1))

5. LQQ (Linearly Quadratically Quadratic): \[ \rho(x) = \begin{cases} \frac{x^2}{2} & \text{si } |x| \leq c_1 \\ c_1|x| - \frac{c_1^2}{2} & \text{si } c_1 < |x| \leq c_2 \\ \frac{(c_3|x| - x^2/2)}{c_3-c_2} & \text{si } c_2 < |x| \leq c_3 \\ c_3 & \text{si } |x| > c_3 \end{cases} \quad \text{(11)} \]

getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "LQQ", par = c(-.5,1.5,.95,NA))

6. Optimal \[ \psi(x) = \begin{cases} x & \text{si } |x| \leq a \\ a \cdot \text{sign}(x) \cdot \left(1 - \left(\frac{|x| - a}{b - a}\right)^2\right)^2 & \text{si } b < |x| \leq c \\ 0 & \text{si } |x| > c \end{cases} \quad \text{(12)} \]

getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "optimal", par = 1.06, leg.loc="bottomright")

Donde \(k\), \(a\), \(b\), \(c\), \(c_1\), \(c_2\) y \(c_3\) son constantes que determinan los puntos de quiebre y la forma de cada función.

Existen muchas otras propuestas de estimadores robustos para regresión, por ejemplo LMS (least median of squares), LTS (least trimmed squares), τ−estimadores de regresión, y casi todas están implementadas en R.

Dataset

El set de datos consiste en dos bases, ambas obtenidas de Kaggle.

La base de datos con los precios de los jugadores se obtuvo de la web Transfermarkt. Cuenta con 32405 registros, y dos de sus variables son los precios actuales de los jugadores y el precio mas alta alcanzado. Además cuenta con la información del club y liga actual de cada jugador.

Las otra base de datos cuenta con las métricas durante la temporada 2023/2024 de los jugadores de las 5 ligas mas importantes del fútbol europeo. Algunas de sus variables son Edad, goles anotados, asistencias, posición dentro del campo de juego, nacionalidad, entre otras.

Ambas bases de datos se unieron por el nombre y apellido del jugador, y el club actual. Adicionalmente, se agregó la variable Continente al dataset final, la cual informa el continente natal de cada jugador.

El dataset se divide en Entrenamiento y Prueba, de manera estratificada según el precio. Se utiliza el siguiente boxplot para generar una nueva categoría que categorice según el precio del jugador.

Luego utilizaremos esta nueva variable para realizar la división del dataset de manera estratificada.

Categorías de la nueva variable

• Muy bajo: Menor a mediana (Q2)
• Bajo: entre mediana (Q2) y cuartil superior (Q3)
• Medio: entre cuartil superior (Q3) y límite superior (Q3 + 1.5 x IQR)
• Alto: entre limite superior y €100.000.000
• Muy Alto: mayor a €100.000.000 (representa los 10 jugadores mas caros)

El objetivo es que quedan estratificados los jugadores mas caros u outliers, por eso no se realiza una división por debajo de Q2.

# Carga de datset
# setwd("/Users/jorgefernandez/Documents/Cienciadedatos/EEA2024/TP02")
setwd("/Users/rmarques/UBA/EEA/german-eea-2024/TP02")
df <- as.data.frame(read.csv("dataset.csv"))
df <- as.data.frame(df)
df <- na.omit(df)
colnames(df)[colnames(df) == "market_value_in_eur"] <- "precio"

# Agregar nueva variable que tenga en cuenta los precios de los jugadores y poder hacer un split 
# test-train estratificado
caja_precios <- boxplot(df$precio)

df$precio_cat <- NA

for (i in 1:length(df$precio)) {
  if (df$precio[i] >= 100000000) { 
    df$precio_cat[i] <- "muy_alto"}
  if (df$precio[i] < 100000000 && df$precio[i] >= caja_precios$stats[5]) {
    df$precio_cat[i] <- "alto"}
  if (df$precio[i] < caja_precios$stats[5] && df$precio[i] >= caja_precios$stats[4]) {
    df$precio_cat[i] <- "medio"}
  if (df$precio[i] < caja_precios$stats[4] && df$precio[i] >= caja_precios$stats[3]) {
    df$precio_cat[i] <- "bajo"}
  if (df$precio[i] < caja_precios$stats[3]){
    df$precio_cat[i] <- "muy_bajo"}
}

# Suponiendo que `df$clase` es la variable categórica
set.seed(28749658)  # Fijar semilla para reproducibilidad

# Crear índices estratificados basados en la variable `clase`
train_indices <- createDataPartition(df$precio_cat, p = 0.7, list = FALSE)  # 70% entrenamiento

# Dividir los datos
train_data <- df[train_indices, ]
test_data <- df[-train_indices, ]

Verificar la distribución de clases

Datos de Entrenamiento

table(train_data$precio_cat)

## 
##     alto     bajo    medio muy_alto muy_bajo 
##      132      298      171       10      546

Datos de prueba

table(test_data$precio_cat)

## 
##     alto     bajo    medio muy_alto muy_bajo 
##       56      127       73        4      234

Análisis Exploratorio de Datos

Gráficos de barras de algunas variables categóricas

colnames(df)[colnames(df) == "market_value_in_eur"] <- "precio"
df$continente <- factor(df$continente, levels = c("europa", "america", "africa", "asia_oceania"))
grafico1 <- ggplot(df, aes(x=continente, fill = continente)) +
  geom_bar() +
  scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
  labs(y = "Cantidad", 
       x = "Continente",
       title = "Cantidad de jugadores por continente") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1),
        legend.position = "none")

df$Comp <- factor(df$Comp, levels = c("es La Liga", "it Serie A", "fr Ligue 1", "de Bundesliga",
                                      "eng Premier League"))
grafico2 <- ggplot(df, aes(x=Comp, fill = Comp)) + 
  geom_bar() +
  scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
  labs(y = "Cantidad", x = "Liga", title = "Cantidad de jugadores por liga") +
  theme_minimal() + 
  theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1),
        legend.position = "none")

posiciones <- table(df$position)
posiciones <- names(sort(posiciones))
df$position <- factor(df$position, levels = posiciones)
grafico3 <- ggplot(df, aes(x=position, fill = position)) + 
  geom_bar() +
  scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
  labs(y = "Count", x = "Posiciones", title = "Cantidad de jugadores por posicion") +
  theme_minimal() + 
  theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1,),
        legend.position = "none")

grafico4 <- ggplot(df, aes(x=foot, fill = foot)) + 
  geom_bar() +
  scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
  labs(y = "Count", x = "Pie hábil", title = "Cantidad de jugadores por pie habil") +
  theme_minimal() + 
  theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1,),
        legend.position = "none")

grid.arrange(grafico1, grafico2, grafico3, grafico4,nrow = 2)

Jugadores por continente

Como era de esperarse, predominan los jugadores europeos. Los americanos y africanos están casi en igual medida, siendo un poco mayor los americanos. Asia y Oceanía en conjunto aportan solo una mínima cantidad.

Cantidad de jugadores de liga

Todas las ligas están igual de representadas en el dataset, con lo cual el análisis del precio de jugadores según la liga será de interés.

Jugadores por posición

La mayor cantidad de jugadores son Defensores, y en menor medida los Mediocampistas y Delanteros, pero todas estas posiciones están uniformemente distribuidas. Como es de esperarse, los Arquero es la posición de menor representación.

Jugadores por pie hábil.

Como era de esperarse, mas de la mitad de los jugadores son derechos. Sin embargo, comparado con la proporción de personas diestras en el mundo (85%), la cantidad de jugadores zurdos es bastante mayor a estar proporción.

Correlograma

df %>% 
  dplyr::select(Age, Gls, Ast, precio) %>% 
  mutate(liga = df$current_club_domestic_competition_id) %>%
  ggpairs(., mapping = aes(colour = liga),
          upper = list(continuous = wrap("cor", size = 3, hjust=0.5)), progress=FALSE) + 
  scale_color_viridis_d(option = "D") + 
  scale_fill_viridis_d(option = "D") +
  theme(axis.text.x = element_text(angle = 90, hjust = 1), legend.position = "bottom") + 
  theme_bw() +
  labs(title='Correlograma variables continuas')

Correlación entre Goles y Precio

Se observa una correlación positiva alta a moderada (Corr: 0.502). Esto sugiere que los jugadores que marcan más goles tienden a tener un valor de mercado más alto. La relación parece ser consistente a través de las diferentes ligas. Siendo menos pronunciada en las ligas española y francesa donde parecería que la cantida de goles anotados tiene menos importancia que en el resto de las ligas, y mas pronunciada en la liga inglesa donde parecería que la cantida de goles anotados tiene mas importancia que el resto de las ligas.

Correlación entre Asistencias y Precio

Existe una correlación positiva moderada (Corr: 0.465). Indica que los jugadores que dan más asistencias también tienden a tener un mayor valor en el mercado. La correlación es algo menor que con los goles, sugiriendo que el mercado valora más la capacidad goleadora. Se observa la misma tendencia que para la cantidad de goles, es menos pronunciada en las ligas española y francesa donde parecería que la cantida de asistencias tiene menos importancia que en el resto de las ligas, y mas pronunciada en la liga inglesa donde parecería que la cantida de asistencias tiene mas importancia que el resto de las ligas.

Correlación entre Edad y Precio

Se observa una correlación negativa baja pero clara (Corr: -0.176). Sugiere que el valor de mercado tiende a disminuir con la edad del jugador. Esto tiene sentido desde una perspectiva de inversión, ya que los jugadores más jóvenes tienen mayor potencial de desarrollo y años de carrera por delante. En este caso, la liga español tiene una pendiente mas negativa lo que podría evidenciar que los jugadores jovenes son mas valorados que el resto de las ligas, en cambio en la liga francesa se observa una pendiente mas suave con lo cual podría indicar que se valora mas la experiencia que el resto de las ligas.

Distribución por Ligas

Los diagramas de caja (boxplots) muestran diferencias en la distribución de precios entre ligas. Las ligas española y británica presentan valores más altos en general. Esto se alinea con el poder económico de estas ligas y específicamente de clubes como Real Madrid y Manchester City. La distribución de precios es notablemente asimétrica, con algunos valores muy altos que podrían considerarse outliers.

Correlaciones cruzadas

Existe una correlación positiva moderada entre goles y asistencias (Corr: 0.586). Esto sugiere que los jugadores más efectivos tienden a destacar tanto en goles como en asistencias. La edad muestra correlaciones muy débiles con goles y asistencias.

Jugadores mas caros

Los 10 jugadores mas caros

mas_caros_nombre <- df %>% 
  slice_max(order_by = precio, n=10)  %>% 
  pull(name)
mas_caros_equipo <- df %>% 
  slice_max(order_by = precio, n=10)  %>% 
  pull(Squad)
mas_caros_precio <- df %>% 
  slice_max(order_by = precio, n=10)  %>% 
  pull(precio)
mas_caro <- data.frame(Nombre = mas_caros_nombre, 
                       Equipo = mas_caros_equipo, 
                       Precio = mas_caros_precio)

kable(mas_caro)

Nombre	Equipo	Precio
erling haaland	manchester city	2.0e+08
vinicius junior	real madrid	2.0e+08
jude bellingham	real madrid	1.8e+08
lamine yamal	barcelona	1.5e+08
phil foden	manchester city	1.5e+08
bukayo saka	arsenal	1.4e+08
federico valverde	real madrid	1.3e+08
florian wirtz	leverkusen	1.3e+08
rodri	manchester city	1.3e+08
declan rice	arsenal	1.2e+08

Jugadores mas baratos

Los 10 jugadores mas baratos

mas_baratos_nombre <- df %>% 
  slice_min(order_by = precio, n=10)  %>% 
  pull(name)
mas_baratos_equipo <- df %>% 
  slice_min(order_by = precio, n=10)  %>% 
  pull(Squad)
mas_baratos_precio <- df %>% 
  slice_min(order_by = precio, n=10)  %>% 
  pull(precio)
mas_barato <- data.frame(Nombre = mas_baratos_nombre, 
                       Equipo = mas_baratos_equipo, 
                       Precio = mas_baratos_precio)

kable(mas_barato)

Nombre	Equipo	Precio
aurelien pelon	lorient	50000
daouda traore	nice	50000
sofiane sidi ali	marseille	50000
steven baseya	strasbourg	50000
yassin tallal	getafe	50000
simone aresti	cagliari	75000
adel mahamoud	nantes	100000
antonio mirante	milan	100000
daniele sommariva	genoa	100000
dominic sadi	bournemouth	100000
francesco rossi	atalanta	100000
ichem ferrah	lille	100000
ivan cuellar	mallorca	100000
joel imasuen	werder bremen	100000

Regresión Lineal Simple

Modelo “Goles son amores”

Precio = Goles

modelo_clasico_goles = lm(data = train_data, formula = precio ~ Gls)
summary(modelo_clasico_goles)

## 
## Call:
## lm(formula = precio ~ Gls, data = train_data)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -58318585  -5505828  -3505828   2261548 112681415 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  5238452     519499   10.08   <2e-16 ***
## Gls          3267375     147163   22.20   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 15400000 on 1155 degrees of freedom
## Multiple R-squared:  0.2991, Adjusted R-squared:  0.2985 
## F-statistic: 492.9 on 1 and 1155 DF,  p-value: < 2.2e-16

ggplot(df, aes(x= Gls, y=precio))+
  geom_point() +
  theme_bw() +
  geom_smooth(method = "lm", formula = y ~ x, color="forestgreen", se = FALSE)

Diagnóstico

datos_augmentados <- augment(modelo_clasico_goles)
g1 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
  geom_point() +
  geom_hline(yintercept = 0) +
  geom_smooth(se = FALSE) +
  labs(title = "Residuos vs valores predichos") + 
  theme_bw()
g2 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
  stat_qq() +
  geom_abline() +
  labs(title = "Normal QQ plot") + 
  theme_bw()
g3 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
  geom_point() +
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Scale-location plot")
g4 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
  geom_vline(size = 2, colour = "white", xintercept = 0) +
  geom_hline(size = 2, colour = "white", yintercept = 0) +
  geom_point() + 
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Residual vs leverage")
grid.arrange(g1, g2, g3, g4, nrow=2)

Diagnóstico de Residuos

• El gráfico de residuos vs valores predichos muestra un patrón de embudo, indicando heterocedasticidad
• El QQ-plot muestra desviaciones significativas de la normalidad, especialmente en las colas
• El Scale-location plot confirma la heterocedasticidad, con mayor variabilidad en los valores predichos más altos
• El gráfico de leverage muestra varios puntos con alta influencia que podrían estar afectando el modelo

Interpretación del Modelo

• El modelo establece una relación lineal simple entre el precio del jugador y los goles anotados
• Por cada gol anotado, se precibe un aumento estadísticamente significativo (p-value < 0.05) en el precio del jugador de €3,267,375
• El intercepto es €5,238,452, que representa el precio base estimado para un jugador sin goles
• El modelo es estadísticamente significativo (p-value < 2.2e-16)
• El R² ajustado es 0.2985, lo que indica que el modelo explica aproximadamente el 30% de la variabilidad en los precios

Evaluación del Rendimiento

Datos de entrenamiento

pred_modelo_clasico_goles <- augment(modelo_clasico_goles, newdata = train_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  15388866

cat("MAE: ", mae(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)

## MAE:  9179813

Datos de prueba

pred_modelo_clasico_goles <- augment(modelo_clasico_goles, newdata = test_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  17503869

cat("MAE: ", mae(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)

## MAE:  9732598

• En datos de entrenamiento:
  • RMSE: 15,388,866
  • MAE: 9,179,813
• En datos de prueba:
  • RMSE: 17,503,869
  • MAE: 9,732,598
• La diferencia relativamente pequeña entre los errores de entrenamiento y prueba sugiere que el modelo no está sobreajustado

Limitaciones del Modelo

• La relación lineal simple puede ser demasiado básica para capturar la complejidad del precio de los jugadores
• La presencia de heterocedasticidad sugiere que la variabilidad del precio aumenta con el número de goles
• El bajo R² indica que hay otros factores importantes que no están siendo considerados
• Los supuestos de normalidad y homocedasticidad no se cumplen adecuadamente

Este modelo, aunque estadísticamente significativo, tiene limitaciones importantes para predecir el precio de los jugadores. La violación de los supuestos básicos y el bajo poder explicativo sugieren que se necesita un modelo más complejo que incorpore variables adicionales y posiblemente transformaciones de las variables existentes.

Modelo “La edad NO es lo de menos”

Precio = \(Edad\) + \(Edad^2\)

modelo_clasico_edad = modelo_clasico_edad2 = lm(data = train_data, formula = precio ~ Age + I(Age^2))
summary(modelo_clasico_edad)

## 
## Call:
## lm(formula = precio ~ Age + I(Age^2), data = train_data)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -13491197  -9734927  -5198104   2200547 186201791 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -45547305   13549572  -3.362 0.000801 ***
## Age           5113615    1054307   4.850 1.40e-06 ***
## I(Age^2)      -110147      20094  -5.482 5.18e-08 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 17940000 on 1154 degrees of freedom
## Multiple R-squared:  0.05018,    Adjusted R-squared:  0.04853 
## F-statistic: 30.48 on 2 and 1154 DF,  p-value: 1.255e-13

ggplot(df, aes(x= Age, y=precio))+
  geom_point() +
  theme_bw() +
  geom_smooth(method = "lm", formula = y ~ x + I(x^2), color="forestgreen", se = FALSE)

cat("A partir de los", round(5113615/(2*110147),0), "años, el precio de los jugadores comienza a disminuir")

## A partir de los 23 años, el precio de los jugadores comienza a disminuir

Diagnóstico

datos_augmentados <- augment(modelo_clasico_edad)
g1 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
  geom_point() +
  geom_hline(yintercept = 0) +
  geom_smooth(se = FALSE) +
  labs(title = "Residuos vs valores predichos") + 
  theme_bw()
g2 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
  stat_qq() +
  geom_abline() +
  labs(title = "Normal QQ plot") + 
  theme_bw()
g3 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
  geom_point() +
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Scale-location plot")
g4 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
  geom_vline(size = 2, colour = "white", xintercept = 0) +
  geom_hline(size = 2, colour = "white", yintercept = 0) +
  geom_point() + 
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Residual vs leverage")
grid.arrange(g1, g2, g3, g4, nrow=2)

Diagnóstico de Residuos

• El gráfico de residuos vs valores predichos muestra un patrón de embudo similar al modelo anterior
• El QQ-plot muestra desviaciones significativas de la normalidad, especialmente en las colas superiores
• El Scale-location plot indica heterocedasticidad
• El gráfico de leverage muestra algunos puntos influyentes, aunque menos pronunciados que en el modelo de goles

Interpretación del Modelo

• El modelo establece una relación cuadrática entre el precio del jugador y su edad
• El precio aumenta con la edad hasta los 23 años, punto a partir del cual comienza a disminuir
• Los coeficientes son:
  • Edad: +5,113,615 (efecto lineal positivo)
  • Edad²: -110,147 (efecto cuadrático negativo)
  • Intercepto: -45,547,305
• El modelo es estadísticamente significativo (p-value: 1.255e-13)
• El R² ajustado es 0.04853, lo que indica que el modelo explica solo aproximadamente el 5% de la variabilidad en los precios

Evaluación del Rendimiento

Datos de entrenamiento

pred_modelo_clasico_edad <- augment(modelo_clasico_edad, newdata = train_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  17914627

cat("MAE: ", mae(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)

## MAE:  10519126

Datos de prueba

pred_modelo_clasico_edad <- augment(modelo_clasico_edad, newdata = test_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  18482683

cat("MAE: ", mae(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)

## MAE:  10655848

• En datos de entrenamiento:
  • RMSE: 17,914,627
  • MAE: 10,519,126
• En datos de prueba:
  • RMSE: 18,482,683
  • MAE: 10,655,848
• Los errores son mayores que en el modelo de goles, sugiriendo que la edad por sí sola es un predictor más débil del precio

Limitaciones del Modelo

• El muy bajo R² sugiere que la edad por sí sola no es un buen predictor del precio
• La relación cuadrática captura el hecho de que los jugadores alcanzan un pico de valor, pero el ajuste general es pobre
• Los supuestos de normalidad y homocedasticidad siguen sin cumplirse
• El modelo no captura otros factores importantes que afectan el precio

Este modelo confirma que existe una relación no lineal entre la edad y el precio de los jugadores, con un punto máximo alrededor de los 23 años. Sin embargo, su bajo poder explicativo sugiere que la edad debe combinarse con otras variables para obtener predicciones más precisas.

Regresión Lineal Múltiple

Modelo “Ahora va en serio”

\(Precio\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)

modelo_clasico_multiple_1 = lm(data = train_data, 
                             formula = precio ~ Gls + Age + I(Age^2) + Ast + 
                               continente + current_club_domestic_competition_id)
summary(modelo_clasico_multiple_1)

## 
## Call:
## lm(formula = precio ~ Gls + Age + I(Age^2) + Ast + continente + 
##     current_club_domestic_competition_id, data = train_data)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -37702078  -5979937  -1352304   4179402 117568853 
## 
## Coefficients:
##                                         Estimate Std. Error t value Pr(>|t|)
## (Intercept)                             -8999579   10503367  -0.857 0.391719
## Gls                                      2189855     160682  13.629  < 2e-16
## Age                                      1607300     804050   1.999 0.045844
## I(Age^2)                                  -44966      15312  -2.937 0.003384
## Ast                                      2152607     244624   8.800  < 2e-16
## continenteamerica                        4494113    1848911   2.431 0.015223
## continenteasia_oceania                   2283362    3956794   0.577 0.564003
## continenteeuropa                         2748364    1459721   1.883 0.059981
## current_club_domestic_competition_idFR1 -4436917    1268565  -3.498 0.000487
## current_club_domestic_competition_idGB1 11060116    1286087   8.600  < 2e-16
## current_club_domestic_competition_idIT1 -2429060    1229943  -1.975 0.048515
## current_club_domestic_competition_idL1  -4011806    1265818  -3.169 0.001568
##                                            
## (Intercept)                                
## Gls                                     ***
## Age                                     *  
## I(Age^2)                                ** 
## Ast                                     ***
## continenteamerica                       *  
## continenteasia_oceania                     
## continenteeuropa                        .  
## current_club_domestic_competition_idFR1 ***
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1 *  
## current_club_domestic_competition_idL1  ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 13350000 on 1145 degrees of freedom
## Multiple R-squared:  0.4783, Adjusted R-squared:  0.4733 
## F-statistic: 95.43 on 11 and 1145 DF,  p-value: < 2.2e-16

Diagnóstico

datos_augmentados <- augment(modelo_clasico_multiple_1)
g5 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
  geom_point() +
  geom_hline(yintercept = 0) +
  geom_smooth(se = FALSE) +
  labs(title = "Residuos vs valores predichos") + 
  theme_bw()
g6 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
  stat_qq() +
  geom_abline() +
  labs(title = "Normal QQ plot") + 
  theme_bw()
g7 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
  geom_point() +
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Scale-location plot")
g8 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
  geom_vline(size = 2, colour = "white", xintercept = 0) +
  geom_hline(size = 2, colour = "white", yintercept = 0) +
  geom_point() + 
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Residual vs leverage")
grid.arrange(g5, g6, g7, g8, nrow=2)

Diagnóstico de Residuos

• El gráfico de residuos vs valores predichos muestra una mejora en el patrón de heterocedasticidad
• El QQ-plot indica una mejor aproximación a la normalidad en el centro de la distribución
• El Scale-location plot muestra una variabilidad más estable que los modelos anteriores
• El gráfico de leverage identifica menos puntos influyentes extremos

Interpretación del Modelo

• El modelo incorpora múltiples variables predictoras: goles, edad (lineal y cuadrática), asistencias, continente de origen y liga
• Los coeficientes más significativos son:
  • Goles: +2,189,855 por gol (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de asistencias y edad aumenta €2,189,855 por cada gol anotado
  • Asistencias: +2,152,607 por asistencia (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de goles y edad aumenta €2,152,607 por cada asistencia adicional.
  • Edad: efecto cuadrático con máximo alrededor de los 23 años
  • América: +4,494,113 respecto a África (p-value = 0.015)
  • Premier League: +11,060,116 respecto a la liga de referencia, La Liga (España) (p-value < 2e-16)
  • Ligue 1: -4,436,917 respecto a la liga de referencia, La Liga (p-value < 0.05)
  • Bundesliga: -4,011,806 respecto a la liga de referencia, La Liga (p-value < 0.05)
  • Serie A (Italia): -2,429,060 respecto a la liga de referencia, La Liga (p-value < 0.05)
• El R² ajustado es 0.4733, indicando que el modelo explica aproximadamente el 47% de la variabilidad

Evaluación del Rendimiento

Datos de entrenamiento

pred_modelo_clasico_multiple_1 <- augment(modelo_clasico_multiple_1, newdata = train_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  13276913

cat("MAE: ", mae(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)

## MAE:  8093280

Datos de prueba

pred_modelo_clasico_multiple_1 <- augment(modelo_clasico_multiple_1, newdata = test_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  15450180

cat("MAE: ", mae(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)

## MAE:  8469906

• En datos de entrenamiento:
  • RMSE: 13,276,913
  • MAE: 8,093,280
• En datos de prueba:
  • RMSE: 15,450,180
  • MAE: 8,469,906
• La diferencia moderada entre errores de entrenamiento y prueba sugiere un nivel aceptable de generalización

Mejoras Respecto a Modelos Anteriores

• El R² ajustado aumentó significativamente (de 0.30 y 0.05 a 0.47)
• Los errores de predicción (RMSE y MAE) disminuyeron
• Los diagnósticos de residuos muestran mejores propiedades estadísticas
• La incorporación de variables categóricas captura efectos específicos por continente y liga

Este modelo representa una mejora sustancial sobre los modelos simples anteriores, capturando efectos más complejos y reduciendo los errores de predicción. Sin embargo, aún hay espacio para mejoras, especialmente en el tratamiento de valores extremos y la posible incorporación de más variables relevantes.

Modelo “Ahora va en serio 2”

\(log(Precio)\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)

Al utilizar una transformación logarítmica, la interpretación del modelo es diferente, ya que se introduce una relación de semielasticidad entre las variables. La variación de la variable a predecir es en términos porcentuales según aumenta en una unidad la variable predictora numérica o según la variable de referencia categórica.

Por lo tanto:

\[ c = (\exp(b) - 1) \times 100 \quad \text{(13)} \]

Donde

\[ y = a + b \times x \quad \text{(14)} \]

En este caso, si \(x\) es una variable numérica entonces \(y\) varía \(c\)% por cada aumento de \(x\) en una unidad. Si en cambio \(x\) es una variable categórica, \(y\) varía \(c\)% con respecto a la variable categórica de referencia.

modelo_clasico_multiple = lm(data = train_data, 
                                formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                  continente + current_club_domestic_competition_id)
summary(modelo_clasico_multiple)

## 
## Call:
## lm(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + continente + 
##     current_club_domestic_competition_id, data = train_data)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -4.0055 -0.6931  0.0515  0.7146  3.5105 
## 
## Coefficients:
##                                          Estimate Std. Error t value Pr(>|t|)
## (Intercept)                              5.573579   0.844203   6.602 6.19e-11
## Gls                                      0.116194   0.012915   8.997  < 2e-16
## Age                                      0.787591   0.064625  12.187  < 2e-16
## I(Age^2)                                -0.016285   0.001231 -13.232  < 2e-16
## Ast                                      0.172888   0.019662   8.793  < 2e-16
## continenteamerica                        0.404139   0.148605   2.720  0.00664
## continenteasia_oceania                   0.007232   0.318025   0.023  0.98186
## continenteeuropa                         0.041694   0.117324   0.355  0.72237
## current_club_domestic_competition_idFR1 -0.296188   0.101960  -2.905  0.00374
## current_club_domestic_competition_idGB1  0.817675   0.103369   7.910 6.02e-15
## current_club_domestic_competition_idIT1 -0.027229   0.098856  -0.275  0.78303
## current_club_domestic_competition_idL1  -0.285435   0.101740  -2.806  0.00511
##                                            
## (Intercept)                             ***
## Gls                                     ***
## Age                                     ***
## I(Age^2)                                ***
## Ast                                     ***
## continenteamerica                       ** 
## continenteasia_oceania                     
## continenteeuropa                           
## current_club_domestic_competition_idFR1 ** 
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1    
## current_club_domestic_competition_idL1  ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.073 on 1145 degrees of freedom
## Multiple R-squared:  0.467,  Adjusted R-squared:  0.4619 
## F-statistic: 91.21 on 11 and 1145 DF,  p-value: < 2.2e-16

Diagnóstico

Los siguientes histogramas muestran como mejora la ditribución de los precios aplicando la distribución lograrítmica logrando una aproximación a los normalidad y homocedasticidad de los datos a predecir.

hist1 <- ggplot(df, aes(x=precio))+
  geom_histogram() +
  labs(title = "Histograma del Precio") + 
  theme_bw()
hist2 <- ggplot(df, aes(x=log(precio)))+
  geom_histogram() +
  labs(title = "Histograma del log(Precio)") + 
  theme_bw()
grid.arrange( hist1, hist2, nrow=1)

En este caso, el valor de \(R^2\) ajustado del modelo es con respecto a la variable transformada, por lo tanto tenemos que predecir todos los datos utilizados en el modelo y trasformarlos exponencialmente para obtener el valor real del salario por hora esperado.

Finalmente, se calcula el valor de \(R^2\) ajustado “manualmente”.

pred_modelo_clasico_multiple <- augment(modelo_clasico_multiple, newdata = train_data)
pred_modelo_clasico_multiple$exp_fitted <- exp(pred_modelo_clasico_multiple$.fitted)
metricas1 = metrics(data = pred_modelo_clasico_multiple,
                    truth = precio, estimate = exp_fitted) %>% 
  mutate(.estimate = round(.estimate, 4))
#rcuadrado <- metricas1$.estimate[2]
#cat("R-cuadrado = ", rcuadrado)
#metricas1
# Calcular el R² ajustado manualmente
n <- nrow(pred_modelo_clasico_multiple)  # Número de observaciones
p <- length(coef(modelo_clasico_multiple)) - 1  # Número de predictores (restamos 1 por el intercepto)

r2 <- metricas1 %>% filter(.metric == "rsq") %>% pull(.estimate)
r2_ajustado <- 1 - ((1 - r2) * (n - 1) / (n - p - 1))

# Mostrar el R² ajustado
cat("R^2 ajustado = ", r2_ajustado)

## R^2 ajustado =  0.2908521

datos_augmentados <- augment(modelo_clasico_multiple)
g9 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
  geom_point() +
  geom_hline(yintercept = 0) +
  geom_smooth(se = FALSE) +
  labs(title = "Residuos vs valores predichos") + 
  theme_bw()
g10 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
  stat_qq() +
  geom_abline() +
  labs(title = "Normal QQ plot") + 
  theme_bw()
g11 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
  geom_point() +
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Scale-location plot")
g12 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
  geom_vline(size = 2, colour = "white", xintercept = 0) +
  geom_hline(size = 2, colour = "white", yintercept = 0) +
  geom_point() + 
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Residual vs leverage")
grid.arrange(g9, g10, g11, g12, nrow=2)

Diagnóstico de Residuos

• El gráfico de residuos vs valores predichos muestra una distribución más homogénea
• El QQ-plot indica una notable mejora en la normalidad de los residuos
• El Scale-location plot muestra una varianza más estable
• El gráfico de leverage sugiere menos influencia de valores extremos

Interpretación del Modelo

• El modelo utiliza la transformación logarítmica de la variable precio y mantiene las mismas variables predictoras
• Los coeficientes más significativos son:
  • Goles: +0.116 (p-value < 2e-16).Esto indica que el precio de los jugadores que tienen misma cantidad de asistencias y edad aumenta un 12.3% por cada gol anotado.
  • Asistencias: +0.173 (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de goles y edad aumenta un 18.9% por cada asistencia adicional.
  • Edad: efecto cuadrático significativo (p-value < 2e-16)
  • América: +0.404 respecto a África (p-value = 0.007), indica un aumento estadísticamete significativo de 49.8% en el precio de los jugadores americanos con respecto a los africanos.
  • Premier League: +0.818 respecto a la liga de referencia, (p-value < 2e-16) indica un aumento estadísticamente significativo de 126.5% en el precio de los jugadores de la Premier League con respecto a los jugadores de La Liga (España)
  • Ligue 1 (Francia): -0.296 respecto a la liga de referencia, (p-value = 0.003) indica una disminución estadísticamente significativa de 25.6% en el precio de los jugadores de la Ligue 1 con respecto a los jugadores de La Liga.
  • Bundesliga: -0.285 respecto de la liga de referencia (p-value = 0.005) indica una disminución estadísticamente significativa de 24.8% en el preicio de los jugadores de la Bundesliga con respecto a La Liga.
• El R² ajustado es 0.29, menor al modelo anterior pero con mejor interpretabilidad y diagnóstico.

Evaluación del Rendimiento

Datos de entrenamiento

cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)

## RMSE:  28500598

cat("MAE: ", mae(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)

## MAE:  8057781

Datos de prueba

pred_modelo_clasico_multiple <- augment(modelo_clasico_multiple, newdata = test_data)
pred_modelo_clasico_multiple$exp_fitted <- exp(pred_modelo_clasico_multiple$.fitted)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)

## RMSE:  17508456

cat("MAE: ", mae(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)

## MAE:  7357616

• En datos de entrenamiento:
  • RMSE: 28,500,598
  • MAE: 8,057,781
• En datos de prueba:
  • RMSE: 17,508,456
  • MAE: 7,357,616
• La transformación logarítmica mejora el MAE en los datos de prueba, aunque el RMSE es más alto

Mejoras Respecto al Modelo Anterior

• Mejor interpretabilidad de los coeficientes en términos de porcentajes
• Mejor cumplimiento de los supuestos de normalidad y homocedasticidad
• Reducción del MAE en datos de prueba
• Mayor estabilidad en la predicción de valores extremos

La transformación logarítmica del precio mejora las propiedades estadísticas del modelo y facilita la interpretación de los efectos. Este modelo parece más adecuado para predecir el precio de los jugadores, especialmente cuando se considera la interpretabilidad y la estabilidad de las predicciones.

Regresión Lineal Múltiple Robusta

Modelo “Goles son amores ROBUSTOS”

Precio = Goles

Se utiliza el modelo base de Robustbase, donde la fución de pérdida utilizada es la bicuadrada y utiliza el estimador MM.

modelo_lmrob_goles <- lmrob(formula = precio ~ Gls, data=train_data)
pred_modelo_lmrob_goles <- data.frame(
  Gls = train_data$Gls,
  precio_pred = predict(modelo_lmrob_goles, newdata = train_data)
)
summary(modelo_lmrob_goles)

## 
## Call:
## lmrob(formula = precio ~ Gls, data = train_data)
##  \--> method = "MM"
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -11398849  -2040823    -40823   7178107 172914731 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  3040823     233384   13.03  < 2e-16 ***
## Gls           890535     123689    7.20 1.08e-12 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Robust residual standard error: 3632000 
## Multiple R-squared:  0.2183, Adjusted R-squared:  0.2177 
## Convergence in 23 IRWLS iterations
## 
## Robustness weights: 
##  158 observations c(3,19,23,52,55,58,67,76,80,83,89,92,105,112,130,132,141,143,144,156,161,163,164,167,172,173,175,178,190,200,204,212,216,218,226,232,248,253,256,262,265,271,283,287,288,289,290,292,301,309,310,316,319,321,322,327,333,338,339,341,354,366,367,368,372,384,385,388,390,407,433,461,463,474,476,482,484,488,489,500,501,510,526,537,543,563,564,565,575,578,584,586,593,597,602,608,630,634,640,646,662,666,674,691,695,696,705,713,736,753,754,760,764,774,793,799,800,801,806,811,813,823,833,853,857,867,870,871,875,901,913,917,918,929,934,953,954,962,963,965,968,973,982,1024,1036,1052,1053,1063,1070,1091,1096,1100,1123,1124,1132,1134,1138,1154)
##   are outliers with |weight| <= 4.7e-05 ( < 8.6e-05); 
##  44 weights are ~= 1. The remaining 955 ones are summarized as
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
## 0.002176 0.877400 0.959300 0.855000 0.983700 0.999000 
## Algorithmic parameters: 
##        tuning.chi                bb        tuning.psi        refine.tol 
##         1.548e+00         5.000e-01         4.685e+00         1.000e-07 
##           rel.tol         scale.tol         solve.tol          zero.tol 
##         1.000e-07         1.000e-10         1.000e-07         1.000e-10 
##       eps.outlier             eps.x warn.limit.reject warn.limit.meanrw 
##         8.643e-05         4.911e-11         5.000e-01         5.000e-01 
##      nResample         max.it       best.r.s       k.fast.s          k.max 
##            500             50              2              1            200 
##    maxit.scale      trace.lev            mts     compute.rd fast.s.large.n 
##            200              0           1000              0           2000 
##                   psi           subsampling                   cov 
##            "bisquare"         "nonsingular"         ".vcov.avar1" 
## compute.outlier.stats 
##                  "SM" 
## seed : int(0)

El siguiente gráfico muestra la linea de regresión del modelo lineal clásico (violeta) frente a la regresión del modelo robusto (amarillo).

Se puede apreciar muy claramente como el modelo robusto tiene una pendiente mas baja ajustando en menor medida a los jugadores de mayor cotización.

ggplot(train_data, aes(x = Gls, y = precio)) +
  geom_point() +
  geom_smooth(method = "lm", formula = y ~ x, color="darkviolet", se = FALSE) +
  geom_line(data = pred_modelo_lmrob_goles, aes(x = Gls, y = precio_pred), color = "yellow") +
  theme_bw()

Interpretación del Modelo

• El modelo establece una relación lineal simple entre el precio del jugador y los goles anotados
• Por cada gol anotado, el precio del jugador aumenta en €890,535; mucho menor al estimado por el método clásico de €3,267,375
• El intercepto es €3,040,824, que representa el precio base estimado para un jugador sin goles también presente una notable baja frente al del modelo clásico de €5,238,452
• El R² ajustado es 0.2177, lo que indica que el modelo explica aproximadamente el 21.8% de la variabilidad en los precios, observando una dismunición considerable frente al 30% del modelo clásico.

Evaluación y comparación de modelos frente a datos de prueba

modelos_simples <- list(simple_1 = modelo_clasico_goles, 
                simple_2 = modelo_lmrob_goles)

lista_predicciones_testing = map(.x = modelos_simples, .f = augment, newdata = test_data) 


goles_clasico_test = lista_predicciones_testing$simple_1 %>%  
  metrics(truth=precio, estimate=.fitted) %>%
  mutate(.estimate=round(.estimate, 4))

goles_robusto_test = lista_predicciones_testing$simple_2 %>%  
  metrics(truth=precio, estimate=.fitted) %>%
  mutate(.estimate=round(.estimate, 4))


metrica_goles <- rbind(goles_clasico_test[c(1,3),], goles_robusto_test[c(1,3),])

modelitos_simples <- c(rep("Clasico - Goles",2),rep("Robusto - Goles",2))
metricas <- cbind(modelitos_simples, metrica_goles)
kable(metricas)

modelitos_simples	.metric	.estimator	.estimate
Clasico - Goles	rmse	standard	17503869
Clasico - Goles	mae	standard	9732598
Robusto - Goles	rmse	standard	19142968
Robusto - Goles	mae	standard	8713804

• El RMSE es menor para el modelo clásico, sin embargo, al estar trabajando con datos que tienen outliers lo correcto es compararlo contra los valores de MAE.
• El MAE es menor para el modelo robusto, mostrando un mejor desempeño frente al modelo clásico.

Primer Modelo Multiple Robusto

\(Precio\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)

modelo_multiple_lmrob <- lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast + 
                                continente + current_club_domestic_competition_id, 
                                data=train_data)
summary(modelo_multiple_lmrob)

## 
## Call:
## lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast + continente + current_club_domestic_competition_id, 
##     data = train_data)
##  \--> method = "MM"
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -38166107  -1948976    313839   5696751 174801160 
## 
## Coefficients:
##                                          Estimate Std. Error t value Pr(>|t|)
## (Intercept)                             -13710204    3541492  -3.871 0.000114
## Gls                                        526022      90783   5.794 8.86e-09
## Age                                       1499374     264013   5.679 1.71e-08
## I(Age^2)                                   -31880       4959  -6.429 1.89e-10
## Ast                                        833746     130969   6.366 2.80e-10
## continenteamerica                          600051     661817   0.907 0.364771
## continenteasia_oceania                   32964436    5364894   6.144 1.11e-09
## continenteeuropa                          -373158     466154  -0.801 0.423585
## current_club_domestic_competition_idFR1   -491839     341530  -1.440 0.150112
## current_club_domestic_competition_idGB1   3289984     932242   3.529 0.000434
## current_club_domestic_competition_idIT1    -55126     348407  -0.158 0.874309
## current_club_domestic_competition_idL1    -478953     324300  -1.477 0.139983
##                                            
## (Intercept)                             ***
## Gls                                     ***
## Age                                     ***
## I(Age^2)                                ***
## Ast                                     ***
## continenteamerica                          
## continenteasia_oceania                  ***
## continenteeuropa                           
## current_club_domestic_competition_idFR1    
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1    
## current_club_domestic_competition_idL1     
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Robust residual standard error: 3425000 
## Multiple R-squared:  0.4751, Adjusted R-squared:  0.4701 
## Convergence in 24 IRWLS iterations
## 
## Robustness weights: 
##  149 observations c(3,19,23,52,58,67,76,80,83,89,92,112,130,132,143,156,161,163,164,167,172,173,190,200,204,212,216,218,221,226,248,253,256,262,265,271,283,287,288,289,290,292,301,309,310,316,319,321,322,327,333,338,339,341,354,366,367,368,372,374,384,385,388,390,403,407,433,461,463,476,482,489,500,501,510,526,537,543,563,564,565,574,575,578,586,590,593,597,608,630,634,640,644,662,666,674,691,696,705,713,736,746,753,754,760,774,793,799,800,801,811,813,823,833,853,867,870,871,875,901,913,917,918,929,934,953,954,956,962,963,965,968,973,975,982,1019,1024,1036,1054,1063,1070,1091,1096,1123,1124,1130,1134,1138,1154)
##   are outliers with |weight| = 0 ( < 8.6e-05); 
##  72 weights are ~= 1. The remaining 936 ones are summarized as
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
## 0.0002669 0.8555000 0.9522000 0.8486000 0.9836000 0.9990000 
## Algorithmic parameters: 
##        tuning.chi                bb        tuning.psi        refine.tol 
##         1.548e+00         5.000e-01         4.685e+00         1.000e-07 
##           rel.tol         scale.tol         solve.tol          zero.tol 
##         1.000e-07         1.000e-10         1.000e-07         1.000e-10 
##       eps.outlier             eps.x warn.limit.reject warn.limit.meanrw 
##         8.643e-05         2.910e-09         5.000e-01         5.000e-01 
##      nResample         max.it       best.r.s       k.fast.s          k.max 
##            500             50              2              1            200 
##    maxit.scale      trace.lev            mts     compute.rd fast.s.large.n 
##            200              0           1000              0           2000 
##                   psi           subsampling                   cov 
##            "bisquare"         "nonsingular"         ".vcov.avar1" 
## compute.outlier.stats 
##                  "SM" 
## seed : int(0)

Interpretación del Modelo

• El modelo incorpora múltiples variables predictoras: goles, edad (lineal y cuadrática), asistencias, continente de origen y liga
• Los coeficientes más significativos son:
  • Goles: +545,409 por gol (p-value = 9.71e-09). Esto indica que el precio de los jugadores que tienen misma cantidad de asistencias y edad aumenta €€545,409 por cada gol anotado
  • Asistencias: +814,283 por asistencia (p-value = 2.51e-10). Esto indica que el precio de los jugadores que tienen misma cantidad de goles y edad aumenta €814,283 por cada asistencia adicional.
  • Edad: efecto cuadrático
  • La variable continente ya no es significativa a la hora de explicar el precio de los jugadores, pero se observa como se invierte la relación con los jugadores europeas donde los africanos son mas valorados en este modelo que en el simple.
  • Premier League: +3,358,109 respecto a la liga de referencia, La Liga (España) (p-value = 0.000357). Los jugadores de la liga inglesa siguen siendo los mas valorados pero en menor medida que el modelo simple.
  • El resto de las ligas dejan de ser significativas, pero se mantiene la tendencia que estos jugadores son menor valorados que los de la liga española.
• El R² ajustado es 0.3699, indicando que el modelo explica aproximadamente el 37% de la variabilidad, disminuyendo con respecto al 47% del modelo simple

Evaluación y comparación de modelos frente a datos de prueba

modelos_comparacion <- list(multiple_1 = modelo_clasico_multiple_1,
                robusto_1 = modelo_multiple_lmrob)

lista_predicciones_testing = map(.x = modelos_comparacion, .f = augment, newdata = test_data) 


metricas_clasico_test = lista_predicciones_testing$multiple_1 %>% 
  metrics(truth=precio, estimate=.fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas_robusto_test = lista_predicciones_testing$robusto_1 %>%
  metrics(truth=precio, estimate=.fitted) %>%
  mutate(.estimate=round(.estimate, 4))


metrica <- rbind(metricas_clasico_test[c(1,3),], metricas_robusto_test[c(1,3),])

modelitos_comparacion <- c(rep("Multiple - Precio",2),
               rep("Robusto - Precio - psi = bisquare",2))
metricas <- cbind(modelitos_comparacion, metrica)
kable(metricas)

modelitos_comparacion	.metric	.estimator	.estimate
Multiple - Precio	rmse	standard	15450180
Multiple - Precio	mae	standard	8469906
Robusto - Precio - psi = bisquare	rmse	standard	18164916
Robusto - Precio - psi = bisquare	mae	standard	7909289

• El RMSE es menor para el modelo clásico, sin embargo, al estar trabajando con datos que tienen outliers lo correcto es compararlo contra los valores de MAE.
• El MAE es menor para el modelo robusto, mostrando un mejor desempeño frente al modelo clásico.

Segundo Modelo Multiple Robusto

\(log(Precio)\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)

modelo_multiple_lmrob_2 <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                 continente + current_club_domestic_competition_id, 
                               data=train_data)
summary(modelo_multiple_lmrob_2)

## 
## Call:
## lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + continente + current_club_domestic_competition_id, 
##     data = train_data)
##  \--> method = "MM"
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -4.15651 -0.71534  0.01675  0.68707  3.45838 
## 
## Coefficients:
##                                          Estimate Std. Error t value Pr(>|t|)
## (Intercept)                              5.796426   1.235981   4.690 3.06e-06
## Gls                                      0.111085   0.010745  10.339  < 2e-16
## Age                                      0.772800   0.090728   8.518  < 2e-16
## I(Age^2)                                -0.016112   0.001655  -9.734  < 2e-16
## Ast                                      0.170219   0.014713  11.569  < 2e-16
## continenteamerica                        0.439570   0.130353   3.372 0.000771
## continenteasia_oceania                   0.065008   0.310255   0.210 0.834070
## continenteeuropa                         0.089042   0.106069   0.839 0.401378
## current_club_domestic_competition_idFR1 -0.231087   0.106080  -2.178 0.029578
## current_club_domestic_competition_idGB1  0.917136   0.110887   8.271 3.66e-16
## current_club_domestic_competition_idIT1 -0.014964   0.101669  -0.147 0.883015
## current_club_domestic_competition_idL1  -0.282461   0.098817  -2.858 0.004335
##                                            
## (Intercept)                             ***
## Gls                                     ***
## Age                                     ***
## I(Age^2)                                ***
## Ast                                     ***
## continenteamerica                       ***
## continenteasia_oceania                     
## continenteeuropa                           
## current_club_domestic_competition_idFR1 *  
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1    
## current_club_domestic_competition_idL1  ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Robust residual standard error: 1.024 
## Multiple R-squared:  0.4842, Adjusted R-squared:  0.4793 
## Convergence in 17 IRWLS iterations
## 
## Robustness weights: 
##  101 weights are ~= 1. The remaining 1056 ones are summarized as
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
## 0.06249 0.86890 0.94640 0.90070 0.98330 0.99900 
## Algorithmic parameters: 
##        tuning.chi                bb        tuning.psi        refine.tol 
##         1.548e+00         5.000e-01         4.685e+00         1.000e-07 
##           rel.tol         scale.tol         solve.tol          zero.tol 
##         1.000e-07         1.000e-10         1.000e-07         1.000e-10 
##       eps.outlier             eps.x warn.limit.reject warn.limit.meanrw 
##         8.643e-05         2.910e-09         5.000e-01         5.000e-01 
##      nResample         max.it       best.r.s       k.fast.s          k.max 
##            500             50              2              1            200 
##    maxit.scale      trace.lev            mts     compute.rd fast.s.large.n 
##            200              0           1000              0           2000 
##                   psi           subsampling                   cov 
##            "bisquare"         "nonsingular"         ".vcov.avar1" 
## compute.outlier.stats 
##                  "SM" 
## seed : int(0)

pred_modelo_robusto_multiple <- augment(modelo_multiple_lmrob_2, newdata = train_data)
pred_modelo_robusto_multiple$exp_fitted <- exp(pred_modelo_robusto_multiple$.fitted)
metricas2 = metrics(data = pred_modelo_robusto_multiple,
                    truth = precio, estimate = exp_fitted) %>% 
  mutate(.estimate = round(.estimate, 4))
#rcuadrado <- metricas1$.estimate[2]
#cat("R-cuadrado = ", rcuadrado)
#metricas1
# Calcular el R² ajustado manualmente
n_rob <- nrow(pred_modelo_robusto_multiple)  # Número de observaciones
p_rob <- length(coef(modelo_multiple_lmrob_2)) - 1  # Número de predictores (restamos 1 por el intercepto)

r2_rob <- metricas2 %>% filter(.metric == "rsq") %>% pull(.estimate)
r2_ajustado_rob <- 1 - ((1 - r2_rob) * (n_rob - 1) / (n_rob - p_rob - 1))

# Mostrar el R² ajustado
cat("R^2 ajustado = ", r2_ajustado_rob)

## R^2 ajustado =  0.3002414

Interpretación del Modelo

• El modelo utiliza la transformación logarítmica de la variable precio y mantiene las mismas variables predictoras
• Los coeficientes más significativos son:
  • Goles: +0.111 (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de asistencias y edad aumenta un 11.7% por cada gol anotado.
  • Asistencias: +0.170 (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de goles y edad aumenta un 18.5% por cada asistencia adicional.
  • Edad: efecto cuadrático significativo (p-value < 2e-16)
  • América: +0.440 respecto a África (p-value = 0.0008), indica un aumento estadísticamete significativo de 55.2% en el precio de los jugadores americanos con respecto a los africanos. Es mayor con respecto al modelo clásico, con lo cual al quitarle peso a los jugadores mas caros podemos decir que los jugadores americanos son aún mas apreciados que los africanos.
  • Premier League: +0.917 respecto a la liga de referencia, (p-value < 3.66e-16) indica un aumento estadísticamente significativo de 150.2% en el precio de los jugadores de la Premier League con respecto a los jugadores de La Liga (España)
  • Ligue 1 (Francia): -0.231 respecto a la liga de referencia, (p-value = 0.03) indica una disminución estadísticamente significativa de 20.6% en el precio de los jugadores de la Ligue 1 con respecto a los jugadores de La Liga.
  • Bundesliga: -0.282 respecto de la liga de referencia (p-value = 0.004) indica una disminución estadísticamente significativa de 24.6% en el preicio de los jugadores de la Bundesliga con respecto a La Liga.
• El R² ajustado es 0.30, similar al modelo clásico.

Evaluación y comparación de modelos frente a datos de prueba

modelos_comparacion <- list(multiple_2 = modelo_clasico_multiple,
                robusto_2 = modelo_multiple_lmrob_2)

lista_predicciones_testing = map(.x = modelos_comparacion, .f = augment, newdata = test_data) 


metricas2_test = lista_predicciones_testing$multiple_2 %>%  
  mutate(exp_fitted= exp(.fitted)) %>% 
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas3_test = lista_predicciones_testing$robusto_2 %>% 
  mutate(exp_fitted= exp(.fitted)) %>%
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))


metrica <- rbind(metricas2_test[c(1,3),], metricas3_test[c(1,3),])

modelitos_comparacion <- c(rep("Multiple - log(Precio)",2),
               rep("Robusto - log(Precio) - psi = bisquare",2))
metricas <- cbind(modelitos_comparacion, metrica)
kable(metricas)

modelitos_comparacion	.metric	.estimator	.estimate
Multiple - log(Precio)	rmse	standard	17508456
Multiple - log(Precio)	mae	standard	7357616
Robusto - log(Precio) - psi = bisquare	rmse	standard	17592430
Robusto - log(Precio) - psi = bisquare	mae	standard	7302473

• El RMSE es menor para el modelo clásico, sin embargo, al estar trabajando con datos que tienen outliers lo correcto es compararlo contra los valores de MAE.
• El MAE es menor para el modelo robusto, mostrando un mejor desempeño frente al modelo clásico.

Modelos Robustos con otras funciones \(\rho\)

Se aplica la misma fórmula que el modelo anterior pero en lugar de usar la función \(\psi\) por defecto bisqueare hacemos 5 modelos nuevos usando en cada uno diferentes \(\rho\): lqq, welsh, optimal, hampel y ggw.

Evaluación de todos los modelos

modelo_multiple_lmrob_lqq <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                   continente + current_club_domestic_competition_id, 
                                 data=train_data,
                                 psi = "lqq")

modelo_multiple_lmrob_lqq_2 <- lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast + 
                                   continente + current_club_domestic_competition_id, 
                                 data=train_data,
                                 psi = "lqq")

modelo_multiple_lmrob_welsh <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                     continente + current_club_domestic_competition_id, 
                                   data=train_data,
                                   psi = "welsh")

modelo_multiple_lmrob_welsh_2 <- lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast + 
                                     continente + current_club_domestic_competition_id, 
                                   data=train_data,
                                   psi = "welsh")

modelo_multiple_lmrob_optimal <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                       continente + current_club_domestic_competition_id, 
                                     data=train_data,
                                     psi = "optimal")

modelo_multiple_lmrob_optimal_2 <- lmrob(formula = precio ~ Gls + Age + I(Age^2) + Ast + 
                                       continente + current_club_domestic_competition_id, 
                                     data=train_data,
                                     psi = "optimal")

# Agrupar todos los modelos
modelos <- list(
    multiple_1 = modelo_clasico_multiple_1, 
    multiple_2 = modelo_clasico_multiple,
    robusto_1 = modelo_multiple_lmrob,
    robusto_2 = modelo_multiple_lmrob_2,
    robusto_3_1 = modelo_multiple_lmrob_lqq_2,
    robusto_3 = modelo_multiple_lmrob_lqq,
    robusto_4_1 = modelo_multiple_lmrob_welsh_2,
    robusto_4 = modelo_multiple_lmrob_welsh,
    robusto_5_1 = modelo_multiple_lmrob_optimal_2,
    robusto_5 = modelo_multiple_lmrob_optimal
)

# Definir nombres de modelos
modelitos <- c(rep("Clasico - Precio",3),
               rep("Clasico - log(Precio)",3),
               rep("Robusto - Precio",3),
               rep("Robusto - log(Precio) - psi = bisquare",3),
               rep("Robusto - Precio - psi = lqq",3),
               rep("Robusto - log(Precio) - psi = lqq",3),
               rep("Robusto - Precio - psi = welsh",3), 
               rep("Robusto - log(Precio) - psi = welsh",3), 
               rep("Robusto - Precio - psi = optimal",3),
               rep("Robusto - log(Precio) - psi = optimal",3))

# Calcular métricas para entrenamiento y prueba
calcular_metricas <- function(modelo, datos, tipo) {
  pred <- augment(modelo, newdata = datos)
  if("log" %in% names(modelo$call)) {
    pred$pred_final <- exp(pred$.fitted)
  } else {
    pred$pred_final <- pred$.fitted
  }
  
  metrics(data = pred, truth = precio, estimate = pred_final) %>%
    mutate(.estimate = round(.estimate, 4),
           tipo_datos = tipo)
}

# Calcular métricas
metricas_entrenamiento <- map_dfr(modelos, ~calcular_metricas(., train_data, "Entrenamiento"), .id = "modelo")
metricas_prueba <- map_dfr(modelos, ~calcular_metricas(., test_data, "Prueba"), .id = "modelo")

# Crear dataframe de métricas
df_metricas <- data.frame(
  modelo = rep(modelitos, 2),
  tipo_datos = c(metricas_entrenamiento$tipo_datos, metricas_prueba$tipo_datos),
  metrica = c(metricas_entrenamiento$.metric, metricas_prueba$.metric),
  valor = c(metricas_entrenamiento$.estimate, metricas_prueba$.estimate)
) %>%
  distinct() %>%
  filter(metrica %in% c("rmse", "mae", "rsq"))

# Gráfico RMSE
ggplot(df_metricas %>% filter(metrica == "rmse"), 
       aes(x = valor, y = modelo, fill = tipo_datos)) +
  geom_col(position = "dodge") +
  geom_text(aes(label = scales::comma(valor)), 
            position = position_dodge(width = 0.9),
            hjust = 1,
            color = "black",
            size = 3) +
  labs(title = "Comparación de RMSE por Modelo",
       x = "RMSE",
       y = "Modelo",
       fill = "Conjunto de datos") +
  scale_fill_manual(values = c("Entrenamiento" = "#99CCFF", "Prueba" = "#003366"))

# Gráfico MAE
ggplot(df_metricas %>% filter(metrica == "mae"), 
       aes(x = valor, y = modelo, fill = tipo_datos)) +
  geom_col(position = "dodge") +
  geom_text(aes(label = scales::comma(valor)), 
            position = position_dodge(width = 0.9),
            hjust = 1,
            color = "black",
            size = 3) +
  labs(title = "Comparación de MAE por Modelo",
       x = "MAE",
       y = "Modelo",
       fill = "Conjunto de datos") +
  scale_fill_manual(values = c("Entrenamiento" = "#99FF99", "Prueba" = "#006600"))

# Gráfico R²
ggplot(df_metricas %>% filter(metrica == "rsq"), 
       aes(x = valor, y = modelo, fill = tipo_datos)) +
  geom_col(position = "dodge") +
  geom_text(aes(label = scales::percent(valor)), 
            position = position_dodge(width = 0.9),
            hjust = 1,
            color = "black",
            size = 3) +
  labs(title = "Comparación de R² por Modelo",
       x = "R² (porcentaje)",
       y = "Modelo",
       fill = "Conjunto de datos") +
  scale_fill_manual(values = c("Entrenamiento" = "#FFB6C1", "Prueba" = "#8B0000"))

• El MAE de todos los modelos robustos es menor que el de los modelos clásicos
• El modelo que utiliza la función \(\rho\) optimal tiene le menor MAE, siendo el de mejor desempeño. Esto es posible ya ya que la funcion optimal es apropiada para datos donde los outliers no son muy pronunciados, que parece ser el caso del precio de los jugadores.

Conclusiones

El análisis estadístico revela patrones fundamentales en la valoración de jugadores que desafían varias percepciones tradicionales del mercado.

La evidencia empírica demuestra una clara segmentación del mercado europeo, con ineficiencias significativas que crean oportunidades estratégicas.

La elección metodológica de utilizar regresión robusta con transformación logarítmica demostró ser crucial para la validez del análisis.

El método MM-estimation implementado en Robustbase, que utiliza por defecto la función bisquare, permitió manejar eficazmente la heterogeneidad inherente al mercado de fichajes, donde las valoraciones extremas son comunes pero no necesariamente outliers estadísticos.

La transformación logarítmica no solo mejoró las propiedades estadísticas del modelo, sino que también proporcionó una interpretación más intuitiva en términos de variaciones porcentuales, alineándose naturalmente con la forma en que el mercado evalúa los cambios en el valor de los jugadores.

El uso de estimadores robustos reveló que el mercado de fichajes, aunque volátil, mantiene una estructura subyacente que puede ser modelada de manera más precisa cuando se utilizan métodos que equilibran robustez y eficiencia estadística.

El modelo robusto, con un R² ajustado de 30%, captura las dinámicas fundamentales del mercado mientras filtra el “ruido” especulativo.

La efectividad de la función bisquare sugiere que, contrario a la percepción popular, las valoraciones extremas en el mercado siguen patrones identificables y no son puramente especulativas.

La Premier League mantiene una prima de valoración del 150.2% sobre La Liga, un diferencial que excede significativamente las diferencias en ingresos operativos entre estas ligas.

Esta sobrevaloración sistemática sugiere una burbuja estructural en el mercado inglés, particularmente notable en comparación con Bundesliga (-24.6%) y Ligue 1 (-20.6%), donde el talento parece estar sistemáticamente infravalorado.

Una observación particularmente relevante es la mayor valoración de las asistencias (+18.5%) sobre los goles (+11.7%). Esta diferencia refleja una evolución en la comprensión del valor creativo en el fútbol moderno, donde la capacidad de generar oportunidades se premia por encima de la finalización. Este patrón sugiere una sofisticación creciente en la evaluación del talento.

La relación cuadrática con la edad emerge como un factor crítico en la valoración, señalando una ventana óptima de valoración que el mercado reconoce consistentemente. Este patrón tiene implicaciones profundas para la gestión de activos deportivos y la planificación de plantillas a largo plazo.

La brecha de valoración del 55.2% entre jugadores americanos y africanos, controlando por rendimiento y liga, revela un sesgo de mercado significativo. Esta disparidad, estadísticamente significativa (p-value = 0.0008), indica una ineficiencia de mercado estructural que trasciende el rendimiento deportivo puro.

Las ineficiencias identificadas en el mercado sugieren que el valor real de un jugador puede diferir significativamente de las valoraciones de mercado actuales, especialmente en ligas secundarias y mercados emergentes. La transformación logarítmica del modelo revela que estas discrepancias siguen patrones predecibles y explotables.

El análisis también señala una evolución en la estructura del mercado, donde los factores tradicionales de valoración están siendo complementados por métricas más sofisticadas. La significativa prima por creatividad sugiere un mercado que está comenzando a valorar más acertadamente las contribuciones tácticas complejas.

Estos hallazgos indican que el mercado de transferencias, aunque cada vez más sofisticado, mantiene ineficiencias estructurales significativas. La combinación de sesgos geográficos, primas de liga y valoración de habilidades específicas crea un panorama complejo pero analíticamente navegable para la identificación de valor.

Bibliografía

• Davidcariboo. (n.d.). Football Data from Transfermarkt [Data set]. Kaggle. https://www.kaggle.com/datasets/davidcariboo/player-scores
• Orkunaktas. (n.d.). Premier League All Players Stats 23/24 [Data set]. Kaggle. https://www.kaggle.com/datasets/orkunaktas/premier-league-all-players-stats-2324
• Apunte de Regresión Lineal. María Eugenia Szretter Noste, Facultad de Ciencias Exactas y Naturales, Universidad de Buenos Aires, Agosto - Octubre de 2017. http://mate.dm.uba.ar/~meszre/apunte_regresion_lineal_szretter.pdf
• Chun Yu & Weixin Yao (2016). Robust linear regression: A review and comparison. Communications in Statistics - Simulation and Computation, https://www.tandfonline.com/doi/abs/10.1080/03610918.2016.1202271
• Clay Ford (2018). Interpreting Log Transformations in a Linear Model. University of Virginia Library. https://library.virginia.edu/data/articles/interpreting-log-transformations-in-a-linear-model